perm filename BMSTF.F4[RST,LCS] blob
sn#207650 filedate 1976-03-24 generic text, type T, neo UTF8
00100 C**** BMSTF, BMS, METER, RNOTE, MAKNUM, IABS, DRWNT, RHORZ, RDRAW
00200 C ********** WHOLE & HALF RESTS, BEAMS ******
00300 SUBROUTINE BMSTF
00400 IMPLICIT INTEGER(A-Q,S-Z)
00500 REAL DIS,DISX,HGT,POS,CENTR,STFF,HGT1
00600 COMMON/STF/RSTFAC(-3/4),RSTJ2/MIN/MINI,RMINI
00700 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/BM/RA,RC,RJY
00800 COMMON/POSI/STFF(-3/4),JJ2,POS/PLTR/PLT,RHT,DIS
00900 COMMON/ALF/QQ(3),RST7,RST18,R3Q,JY,RD,RX,RW,RJX,RJ,L,K,
01000 1 RJA,YY,DISX,HGT,RZ,INP(53)
01100 EQUIVALENCE (J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R5,RJQ(3))
01200 1,(R6,RJQ(4)),(J7,JQ(5)),(J8,JQ(6)),(J9,JQ(7)),(J10,JQ(8))
01300 1,(J11,JQ(9)),(J6,JQ(4)),(R9,RJQ(7)),(R8,RJQ(6)),(R3,RJQ(1))
01400 1 ,(R7,RJQ(5)),(R4,RJQ(2)),(R9,RJQ(7)),(R10,RJQ(8)),(RX3,RJQ(20))
01500 DATA R14/14.54/,RTF/3.0/,RHGT/48.0/,R2HGT/96.0/,RBM/.83/
01600 C RDBR IS SPACER FOR DBL BAR.
01700 C RTF COMPENSATES FOR BAD PLANNING.
01710 IF(JA.NE.8)GO TO 100
01720 CALL STAFF
01730 RETURN
01800 100 RST7=RSTJ2*7.
01900 RST18=RSTJ2*18.
02000 C TO COMPENSATE FOR NOTE #3 COMING AT POS=0
02100
02200 R3Q=R3
02400 C NEXT IS FOR BEAMS
02500 RMINI=RSTJ2
02600 RX=2.7*RSTJ2*5.96
02700 C******************************
02800 R6=RHORZ(R6)
02900 IF(R8.NE.0)GO TO 204
03000 IF(R10.GE.10)GO TO 204
03100 IF(J7)GO TO 204
03200 IF(R9.NE.0)GO TO 1
03300 C R8=0 AND R9=NUM -- PUTS NUMBER OUTSIDE BEAM(FOR TRIPLETS, ETC.)
03400 204 IF(R9.NE.0)R9=RHORZ(R9)
03500 IF(J7)GO TO 201
03600 200 IF(J10.LT.10)GO TO 91
03700 C NEXT FOR INNER, PARTIAL BEAMS
03800 R8=RHORZ(R8)
03900 R10=AMOD(R10,10.)
04000 GO TO(2,3,4),J10/10
04100 2 RH=R9+RX
04200 GO TO 1
04300 3 R8=R9-RX
04400 C 10=SHORT PARTIAL LFT→RT., 20=RT.←LFT, 30=TO POS IN P8
04500 4 RH=R8
04600 C LEFT INNER POS.
04700 GO TO 1
04800 201 J7=-J7
04900 C P8=WIDTH OF TREM. P9=0(SANS OTHER BEAMS) OR =POS.3, P10=DISP.
05000 CALL NOZERO(R10)
05100 C ALWAYS AT LEAST 1 IN DISPLACEMENT
05200 J10=30
05300 C TO ACTIVATE PARTIAL BEAM SECTION
05400 IF(J9.NE.0)GO TO 202
05500 C NEXT FOR TREM. WITHOUT OTHER BEAMS.
05600 RH=-1
05700 IF(J7.GE.20)RH=-RH
05800 CC203 R4=R4+R10*RH
05900 CC CALL CENTX
06000 R5=R4+RH
06100 R9=R3
06200 R6=R3+22.*RMINI
06300 202 IF(R8.EQ.0)R8=4.
06400 RX=R8*RMINI*2.98
06500 RH=R9+RX
06600 R9=R9-RX
06700 GO TO 1
06800
06900 91 IF(J8.EQ.0)GO TO 1
07000 IF(J8.GT.0)GO TO 92
07100 C FOR J8=-(10+DN) OR -(20+DN)
07200 R9=R3+RX
07300 IF(J8.LE.-20)R9=R6-RX
07400 192 J8=-J8
07500 92 IF(J10.EQ.0)J10=MOD(J8,10)
07600 CC??? 4/75 J8=J8-J10
07700 IF(J10.EQ.0)J10=1
07800 R10=J10
07900 C IF P8 NEG, P9 IS AUTOMATIC, ALSO P10 IF NEEDED.
08000 1 IF(IABS(J4).LT.100)GO TO 97
08100 RMINI=.6*RSTJ2
08200 R5=AMOD(R5,100.0)
08300 C SPACE BETWEEN BEAMS
08400 97 RJ=RMINI*11.
08500 RW=RMINI*RHGT
08600 C DIST. UP OR DOWN FROM NOTE HEAD.
08700 RJA=R10*RJ
08800 C DISPLACEMENT
08900 RD=R9
09000 C POSITION 3
09100 RJX=CENTR-RW+RJA
09200 C FINAL HEIGHT OF LEFT SIDE
09300 C NEG R7=TREMOLO
09400 RX=MOD(J7,10)
09500 JJ2=J7-20
09600 RA=R6
09700 C HORIZANTAL DIST.
09800 RJY=R5*RST7+POS-RST18-RW+RJA
09900 C VERTICAL POS OF RIGHT SIDE.
10000 RW=R14*RMINI
10100 RY=1.
10200 IF(J7.GE.20)GO TO 98
10300 C JUMP IF STEMS ARE DOWN
10400 RY=-RY
10500 C FOR THICKENING INCR.
10600 JJ2=J7-10
10700 RJ=-RJ
10800 RJA=RMINI*R2HGT-2.*RJA
10900 RJX=RJX+RJA
11000 RJY=RJY+RJA
11100 R3Q=R3Q+RW
11200 C POSITION 1
11300 RA=RA+RW
11400 C POSITION 2
11500 RD=RD+RW
11600 C******************************
11700 RH=RH+RW
11800 98 RSTJ2=RSTJ2*RBM
11900 C RBM BRINGS LINES OF BEAMS CLOSER TOGETHER. (=.83)
12000 93 IF(JJ2.GT.RX)GO TO 94
12100 IF(J10.GE.10)GO TO 7
12200 C**********************
12300 IF(J8.EQ.0)GO TO 94
12400 R3=RW
12500 IF(J9.EQ.0)GO TO 292
12600 IF(J8.GE.20)GO TO 193
12700 293 RX=R3Q-RD
12800 GO TO 194
12900 7 RHX=RH-R3Q
13000 R3=RD-R3Q
13100 GO TO 292
13200 193 RX=RD-RA
13300 194 R3=ABS(RX)
13400 292 DISX=ABS(R3Q-RA)
13500 HGT=RJX-RJY
13600 IF(J10.GE.10)HGT1=HGT*RHX/DISX
13700 C**********************
13800 R3=R3/DISX
13900 195 HGT=HGT*R3
14000 196 L=J8/10
14100 J8=0
14200 IF(J10.GE.10)GO TO 8
14300 C***************
14400 IF(L.EQ.1)GO TO 95
14500 C BEAM LFT=1, RT=2 (PARAM 8=10 OR 20)
14600 R3Q=RD
14700 RJX=RJY+HGT
14800 GO TO 94
14900 C**************
15000 8 R3Q=RH
15100 RA=RD
15200 RJY=RJX-HGT
15300 RJX=RJX-HGT1
15400 GO TO 94
15500 95 RA=RD
15600 RJY=RJX-HGT
15700 94 L=7.*RMINI
15800 930 RC=0
15900 C MINI LINES HAVE .2 SMALLER BEAMS. MAYBE CHANGE THIS??
16000 CALL LINES(R3Q,RJX,3)
16100 DO 941 K=1,L
16200 CALL BMS
16300 IF(PLT.GE.0)GO TO 940
16400 RC=RC+RY
16500 C FOR THICKENING.
16600 CALL BMS
16700 CALL EXCH(RA,R3Q)
16800 941 CALL EXCH(RJY,RJX)
16900 CALL BMS
17000 C DRAWS 5 LINES FOR BEAMS.
17100 940 JJ2=JJ2-1
17200 IF(JJ2.LE.0)GO TO 942
17300 C IF P7=10 OR 20 ONE BEAM WILL APPEAR.
17400 RJY=RJY+RJ
17500 RJX=RJX+RJ
17600 GO TO 930
17700
17800 942 IF(R8.NE.0)RETURN
17900 IF(R9.EQ.0)RETURN
18000 IF(R10.GE.30)RETURN
18100 C FOR NUMBERS OUTSIDE BEAMS
18200 RSTJ2=RMINI
18300 RD=-10.
18400 IF(R7.LT.20)RD=8.3
18500 943 J3=R3Q+(RA-R3Q)/2.
18600 R6=1.
18700 CC *** DONE IN CENTX *** R4=AMOD(R4,100.)
18800 R4=R4+(R5-R4)/2.+RD
18900 R7=1
19000 C ITALICS
19100 CALL MAKNUM(R9)
19300 END